home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / debug.t < prev    next >
Text File  |  1988-02-05  |  4KB  |  102 lines
  1. (herald debug (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; random collection of debugging stuff
  27.  
  28. ;;; backtrace
  29.  
  30.  
  31. (define (*backtrace frame)
  32.   (format (debug-output) "~& continue into~25t module~40t code~%")
  33.   (do ((frame frame (previous-continuation frame)))
  34.       ((null? frame) repl-wont-print)
  35.     (frame-print-synopsis frame (debug-output))))
  36.                                           
  37. (define (previous-continuation frame)
  38.   (cond ((supreme-frame? frame)
  39.          (get-next-frame frame))
  40.         (else
  41.          (iterate loop ((next (get-next-frame frame)))
  42.            (cond ((null? next) nil)
  43.                  ((supreme-frame? next)
  44.                   (get-next-frame next))
  45.                  (else (loop (get-next-frame next))))))))
  46.              
  47. (define (get-next-frame frame)
  48.   (iterate loop ((frame (frame-previous frame)))
  49.    (cond ((null? frame) nil)
  50.          ((frame? frame) frame)
  51.          (else
  52.           (loop (frame-previous frame))))))
  53.  
  54. (define-operation (frame-print-synopsis frame port)
  55.   (let ((thing (cond ((interpreter-frame? frame)
  56.                       (interpreter-frame-code frame))
  57.                      (else
  58.                       (extend-header frame)))))
  59.     (let ((proc-name (get-proc-name thing))
  60.           (loaded-file (get-loaded-file thing))
  61.           (disclosed (disclose thing)))
  62.       (cond (proc-name (format port " ~s" proc-name))
  63.             (else      (format port " (anonymous)")))
  64.       (cond (loaded-file (format port "~25t ~s" (identification loaded-file)))
  65.             (else        (format port "~25t (none)")))
  66.       (cond (disclosed
  67.              (set (hpos port) 40)
  68.              (write-spaces port 1)
  69.              (print-one-line disclosed port)))
  70.       (newline port))))
  71.  
  72. (define (frame-disclose frame)      ; used by crawl.
  73.   (and (frame? frame)
  74.        (interpreter-frame? frame)
  75.        (disclose (interpreter-frame-code frame))))
  76.  
  77. (define-operation (get-loaded-file obj)
  78.   (cond ((bogus-entity? obj)
  79.          (get-loaded-file (bogus-entity-handler obj)))
  80.         ((template? obj) (template-unit obj))
  81.         ((closure? obj)
  82.          (get-loaded-file (extend-header obj)))
  83.         (else nil)))
  84.  
  85. (define-operation (get-environment obj)
  86.   (cond ((and (frame? obj)
  87.               (interpreter-frame? obj))
  88.          (interpreter-frame-env obj))
  89.         ((bogus-entity? obj)
  90.          (get-environment (bogus-entity-handler obj)))
  91.         ((closure? obj)
  92.          (let ((probe (unit-env (template-unit (extend-header obj)))))
  93.            (cond ((environment? probe) probe)
  94.                  (else nil))))
  95.         (else nil)))
  96.  
  97. (define-operation (disclose obj) nil)
  98.  
  99. (define-operation (where-defined proc)
  100.   (cond ((get-loaded-file proc) => loaded-file-source)
  101.         (else nil)))
  102.